home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / glisp / glisp.000 / GLISP.UNIX.TAR / closunix / clos_lf2.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-04-03  |  14.2 KB  |  617 lines
  1. /*                 GRAPHIC LISP            */
  2. /*        Scritto nel 1991-94 da Zoia Andrea Michele     */
  3. /*        Via Pergola #1 Tirano (SO) Tel. 0342-704210    */
  4. /* file clos_lf2.c */
  5.  
  6. #include "clos.h"
  7.  
  8. /* LF_PARAMS --> (node nin,node_p *nout,node genv,node lenv,unsigned fl ) */
  9. /* convenzioni per le sintassi:
  10.    Metasimboli: { } * + |
  11.     { } Raggruppamento
  12.      *  Zero o piu' occorrenze
  13.      +  Una o piu' occorrenze
  14.      |  OR o l'occorrenza di destra o quella di sinistra
  15.  
  16.   es:
  17.     ( { a | b }+ ) corrisponde a tutte le stringhe del tipo
  18.     ( a a b b a b .... )
  19.     ma non alla stringa ( )
  20. */
  21.  
  22.  
  23. /* funzioni di sistema e di debug ***********************************/
  24. /* GC       , EXIT     , STACKTRACE , TRACE    , UNTRACE            */
  25. /* GETTIME  , OBLIST   , GET_GENV   , GET_LENV , HASHSTAT           */
  26. /* BREAK    , CONTINUE , DRIBBLE                            */
  27. /********************************************************************/
  28.  
  29. /* funzioni varie (da ricontrollare !!!)*****************************/
  30. /* FUNCALL , APPLY RICONTROLLARE, MAPCAR , PUSH , POP , ASSOC                    */
  31. /********************************************************************/
  32.  
  33. /* mettere la funzione TYPE che ritorna il tipo di un nodo */
  34.  
  35. void lf_gc LF_PARAMS
  36. {
  37.  extern hash_t MaxHash;
  38.  extern hash_t HashAllocated;
  39.  
  40.  extern lsiz_t maxname;
  41.  extern lsiz_t nameidx;
  42.  
  43.  lsiz_t alloc_counter;
  44.  lsiz_t free_counter;
  45.  
  46.  if(nin!=NIL){
  47.    sprintf(buf1," Graphic CLOS V%s By Zoia Andrea \n",CLOS_VERSION);
  48.    lisp_print_string(buf1,stdout);
  49.  }
  50.  
  51.  node_gc();
  52.  string_gc();
  53.  node_count(&alloc_counter,&free_counter);
  54.  
  55.  
  56.  sprintf(buf1,"Total Nodes        %7lu Allocated %7lu Free %7lu\n",
  57.         alloc_counter+free_counter,alloc_counter,free_counter);
  58.  lisp_print_string(buf1,stderr);
  59.  
  60.  sprintf(buf1,"Total Strings      %7lu Allocated %7lu Free %7lu\n",
  61.         maxname,nameidx,maxname-nameidx);
  62.  lisp_print_string(buf1,stderr);
  63.  
  64.  sprintf(buf1,"Total Hash Entries %7lu Allocated %7lu Free %7lu\n",
  65.         MaxHash,HashAllocated,MaxHash-HashAllocated);
  66.  lisp_print_string(buf1,stderr);
  67.  
  68.  nout->type=P_ALLNODE;
  69.  nout->node=T;
  70. }
  71.  
  72. void lf_exit LF_PARAMS
  73. {
  74.  if(nin!=NIL)
  75.    error(E_TOOMANYARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&NIL);
  76.  if(dribble_file)fclose(dribble_file);
  77.  lisp_free();
  78.  clos_non_ansi_exit();
  79. }
  80.  
  81.  
  82.  
  83.  
  84. void lf_stacktrace LF_PARAMS
  85. {
  86.  extern int StackTrace;
  87.  if(IS_CONS(nin)){
  88.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  89.    if(calc_pointer(nout)!=NIL)
  90.     StackTrace=TRUE;
  91.    else
  92.     StackTrace=FALSE;
  93.    return;
  94.  }
  95.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  96. }
  97.  
  98.  
  99. void lf_trace LF_PARAMS
  100. {
  101.  /* (TRACE function-name) */
  102.  /* accende il flag trace ritorna t se lo ha acceso , nil se era gia' acceso */
  103.  
  104.  if(IS_CONS(nin)){
  105.    if(IS_NAME(CONSLEFT(nin))){
  106.      if(HAS_FUNCTION(CONSLEFT(nin))){
  107.        if(IS_TRACE(FUNCTION(CONSLEFT(nin)))){
  108.      nout->node=NIL;
  109.        }else{
  110.      nout->node=T;
  111.      TRACE(FUNCTION(CONSLEFT(nin)));
  112.        }
  113.        nout->type=P_ALLNODE;
  114.        return;
  115.      }
  116.      nin=CONSLEFT(nin);
  117.      error(E_UNBOUNDFUNC,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  118.    }
  119.    nin=CONSLEFT(nin);
  120.    error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  121.  }
  122.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  123. }
  124.  
  125. void lf_untrace LF_PARAMS
  126. {
  127.  /* (UNTRACE function-name) */
  128.  /* spegne il flag trace ritorna t se lo ha spento, nil se era gia' spento */
  129.  
  130.  if(IS_CONS(nin)){
  131.    if(IS_NAME(CONSLEFT(nin))){
  132.      if(HAS_FUNCTION(CONSLEFT(nin))){
  133.        if(IS_TRACE(FUNCTION(CONSLEFT(nin)))){
  134.      nout->node=T;
  135.      UNTRACE(FUNCTION(CONSLEFT(nin)));
  136.        }else{
  137.      nout->node=NIL;
  138.        }
  139.        nout->type=P_ALLNODE;
  140.        return;
  141.      }
  142.      nin=CONSLEFT(nin);
  143.      error(E_UNBOUNDFUNC,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  144.    }
  145.    nin=CONSLEFT(nin);
  146.    error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  147.  }
  148.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  149. }
  150.  
  151. void lf_gettime LF_PARAMS
  152. {
  153.  if(nin==NIL){
  154.     TYPE(nout->node=node_make())|=NT_IS_VALUE+NT_INTEGER;
  155.     INTEGER(nout->node)=na_millitime();
  156.     nout->type=P_ALLNODE;
  157.     return;
  158.  }
  159.  error(nin==NIL?E_FEWARGS:E_BADLIST,
  160.     ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  161. }
  162.  
  163.  
  164. void lf_oblist LF_PARAMS
  165. {
  166.  if(nin==NIL){
  167.     nout->node=node_scan();
  168.     nout->type=P_ALLNODE;
  169.     return;
  170.  }
  171.  error(nin==NIL?E_FEWARGS:E_BADLIST,
  172.     ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  173. }
  174.  
  175. void lf_fixlist LF_PARAMS
  176. {
  177.  if(nin==NIL){
  178.     nout->node=node_scan_fix();
  179.     nout->type=P_ALLNODE;
  180.     return;
  181.  }
  182.  error(nin==NIL?E_FEWARGS:E_BADLIST,
  183.     ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  184. }
  185.  
  186.  
  187.  
  188.  
  189. void lf_getlenv LF_PARAMS
  190. {
  191.  if(nin==NIL){
  192.     nout->type=P_ALLNODE;
  193.     nout->node=lenv;
  194.     return;
  195.  }
  196.  error(E_TOOMANYARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  197. }
  198.  
  199.  
  200. void lf_getgenv LF_PARAMS
  201. {
  202.  if(nin==NIL){
  203.     nout->type=P_ALLNODE;
  204.     nout->node=genv;
  205.     return;
  206.  }
  207.  error(E_TOOMANYARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  208. }
  209.  
  210. void lf_hashstat LF_PARAMS
  211. {
  212.  if(nin!=NIL)
  213.      error(E_TOOMANYARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  214.  hash_stat();
  215.  nout->type=P_ALLNODE;
  216.  nout->node=T;
  217. }
  218.  
  219.  
  220. void lf_break LF_PARAMS
  221. {
  222.  if(nin==NIL){
  223.    lisp_main_loop(genv,lenv,node_getlastlock());
  224.    nout->type=P_ALLNODE;
  225.    nout->node=T;
  226.    return;
  227.  }
  228.  error(E_TOOMANYARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  229. }
  230.  
  231. void lf_continue LF_PARAMS
  232. {
  233.  longjmp(break_jmp,LONGJMP_CONTINUE);
  234. }
  235.  
  236. void lf_dribble LF_PARAMS
  237. {
  238.  if(IS_CONS(nin)){
  239.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  240.    nin=calc_pointer(nout);
  241.    nout->type=P_ALLNODE;
  242.    if(nin==NIL){
  243.      if(dribble_file){
  244.        fclose(dribble_file);
  245.        dribble_file=NULL;
  246.        nout->node=T;
  247.      }else{
  248.        nout->node=NIL;
  249.      }
  250.      return;
  251.    }
  252.  
  253.    if(IS_VALUE(nin) && GET_VTYPE(nin)==NT_STRING){
  254.      if(dribble_file){
  255.        nout->node=NIL;
  256.        return;
  257.      }
  258.      string_get(STRING(nin),buf1);
  259.      dribble_file=fopen(buf1,"w+t");
  260.      if(dribble_file){
  261.        nout->node=T;
  262.      }else{
  263.        nout->node=NIL;
  264.      }
  265.      return;
  266.    }
  267.    error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  268.   }
  269.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  270. }
  271.  
  272.  
  273.  
  274.  
  275. /**************************** Funzioni varie ***************************/
  276.  
  277. /* sintassi (funcall funzione {parametri}* ) */
  278. /* chiama la funzione passandole i parametri */
  279. void lf_funcall LF_PARAMS
  280. {
  281.  if(IS_CONS(nin)){
  282.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  283.     apply_func(calc_pointer(nout),CONSRIGHT(nin),nout,genv,lenv,fl);
  284.     return;
  285.  }
  286.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  287. }
  288.  
  289. /* syntax (apply func sx* ) */
  290. /* se e(sx) e' una lista la si copia */
  291. /* se e(sx) non e' una lista si appende l'elemento alla lista gia' esistente*/
  292. void lf_apply LF_PARAMS
  293. {
  294.  node list,func,n1,n2,prev=NIL,first,last;
  295.  
  296.  if(IS_CONS(nin)){
  297.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  298.    func=calc_pointer(nout);
  299.    n1=list=eval_list(CONSRIGHT(nin),genv,lenv);
  300.    while(IS_CONS(n1)){
  301.      n2=CONSLEFT(n1);
  302.      if(IS_CONS(n2)){
  303.        first=n2;
  304.        while(IS_CONS(n2)){
  305.      last=n2;
  306.      n2=CONSRIGHT(n2);
  307.        }
  308.        if(prev==NIL){
  309.      list=first;
  310.        }else{
  311.      CONSRIGHT(prev)=first;
  312.        }
  313.        CONSRIGHT(last)=CONSRIGHT(n1);
  314.        n1=last;
  315.      }
  316.      prev=n1;
  317.      n1=CONSRIGHT(n1);
  318.    }
  319.    apply_func(func,list,nout,genv,lenv,fl);
  320.    return;
  321.  }
  322.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  323. }
  324.  
  325. /* sintassi (mapcar funzione {arglist}*) */
  326. void lf_mapcar LF_PARAMS
  327. {
  328.  node func;
  329.  node parl=node_make();
  330.  node rlist=NIL;
  331.  node last_rnode=nin;
  332.  node p,q,z;
  333.  node quote=node_alloc("QUOTE");
  334.  
  335.  TYPE(parl)|=NT_IS_CONS;
  336.  CONSLEFT(parl)=CONSRIGHT(parl)=NIL;
  337.  
  338.  if(IS_CONS(nin)){
  339.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_SETF);
  340.     func=calc_pointer(nout);
  341.     while(IS_CONS(nin=CONSRIGHT(nin))){
  342.         eval(CONSLEFT(nin),nout,genv,lenv,EVAL_SETF);
  343.         p=parl;
  344.         rlist=calc_pointer(nout);
  345.         /* rlist = (s1 s2 .. sn) */
  346.     while(IS_CONS(rlist)){
  347.             if(CONSLEFT(p)==NIL){
  348.                 TYPE(q=CONSLEFT(p)=node_make())|=NT_IS_CONS;
  349.         TYPE(z=node_make())|=NT_IS_CONS;
  350.         CONSLEFT(z)=quote;
  351.                 TYPE(CONSRIGHT(z)=node_make())|=NT_IS_CONS;
  352.                 CONSLEFT(CONSRIGHT(z))=CONSLEFT(rlist);
  353.         CONSRIGHT(CONSRIGHT(z))=NIL;
  354.                 CONSLEFT(q)=z;
  355.         CONSRIGHT(q)=NIL;
  356.         }else{
  357.         q=CONSLEFT(p);
  358.         while(CONSRIGHT(q)!=NIL) q=CONSRIGHT(q);
  359.         TYPE(CONSRIGHT(q)=node_make())|=NT_IS_CONS;
  360.         TYPE(z=node_make())|=NT_IS_CONS;
  361.         CONSLEFT(z)=quote;
  362.                 TYPE(CONSRIGHT(z)=node_make())|=NT_IS_CONS;
  363.                 CONSLEFT(CONSRIGHT(z))=CONSLEFT(rlist);
  364.                 CONSRIGHT(CONSRIGHT(z))=NIL;
  365.                 CONSLEFT(CONSRIGHT(q))=z;
  366.         CONSRIGHT(CONSRIGHT(q))=NIL;
  367.         }    
  368.         if(CONSRIGHT(p)==NIL){
  369.         TYPE(CONSRIGHT(p)=node_make())|=NT_IS_CONS;
  370.         CONSLEFT(CONSRIGHT(p))=CONSRIGHT(CONSRIGHT(p))=NIL;
  371.         }
  372.         p=CONSRIGHT(p);    
  373.         rlist=CONSRIGHT(rlist);
  374.      }
  375.      }     
  376.      /* parl= ( ('s11 's12 .. 's1n) ('s21 's22 .. 's2n )...('sm1 'sm2 .. 'smn) () )*/
  377.      while(CONSLEFT(parl)!=NIL){
  378.            apply_func(func,CONSLEFT(parl),nout,genv,lenv,EVAL_NORM);
  379.            if(rlist==NIL){
  380.            TYPE(rlist=last_rnode=node_make())|=NT_IS_CONS;
  381.            }else{
  382.                TYPE(CONSRIGHT(last_rnode)=node_make())|=NT_IS_CONS;
  383.                last_rnode=CONSRIGHT(last_rnode);
  384.            }
  385.        CONSLEFT(last_rnode)=calc_pointer(nout);
  386.            CONSRIGHT(last_rnode)=NIL;
  387.            parl=CONSRIGHT(parl);
  388.      }
  389.      nout->node=rlist;
  390.      nout->type=P_ALLNODE;
  391.      return;
  392.  }
  393.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  394. }
  395.  
  396.  
  397. void lf_push LF_PARAMS
  398. {
  399.  /* SINTASSI (push valore lista) */
  400.  node n,value;
  401.  
  402.  if(IS_CONS(nin)){
  403.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  404.    value=calc_pointer(nout);
  405.    if(IS_CONS(CONSRIGHT(nin))){
  406.      eval(CONSLEFT(CONSRIGHT(nin)),nout,genv,lenv,EVAL_NORM);
  407.      TYPE(n=node_make())|=NT_IS_CONS;
  408.      CONSLEFT(n)=value;
  409.      switch(nout->type){
  410.        case P_VALUE:
  411.      CONSRIGHT(n)=VALUE(nout->node);
  412.      VALUE(nout->node)=n;
  413.      nout->node=n;
  414.      nout->type=P_ALLNODE;
  415.      return;
  416.        case P_PLIST:
  417.      CONSRIGHT(n)=PLIST(nout->node);
  418.      PLIST(nout->node)=n;
  419.      nout->node=n;
  420.      nout->type=P_ALLNODE;
  421.      return;
  422.        case P_FUNC:
  423.      CONSRIGHT(n)=FUNCTION(nout->node);
  424.      FUNCTION(nout->node)=n;
  425.      nout->node=n;
  426.      nout->type=P_ALLNODE;
  427.      return;
  428.        case P_CLASS:
  429.      error(E_BADARGS,ERR_MINTERNAL|ERR_TBLVL|ERR_PNODE,&nin);
  430.      break;
  431.        case P_ALLNODE:
  432.      CONSRIGHT(n)=nout->node;
  433.      nout->node=n;
  434.      nout->type=P_ALLNODE;
  435.      return;
  436.        case P_CONSLEFT:
  437.      CONSRIGHT(n)=CONSLEFT(nout->node);
  438.      CONSLEFT(nout->node)=n;
  439.      nout->node=n;
  440.      nout->type=P_ALLNODE;
  441.      return;
  442.        case P_CONSRIGHT:
  443.      CONSRIGHT(n)=CONSRIGHT(nout->node);
  444.      CONSRIGHT(nout->node)=n;
  445.      nout->node=n;
  446.      nout->type=P_ALLNODE;
  447.      return;
  448.  
  449.      }
  450.      nin=calc_pointer(nout);
  451.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  452.    }
  453.  }
  454.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  455. }
  456.  
  457. void lf_pop LF_PARAMS
  458. {
  459.  /* sintassi (POP lista) */
  460.  node n;
  461.  
  462.  if(IS_CONS(nin)){
  463.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  464.      switch(nout->type){
  465.        case P_VALUE:
  466.      if(IS_CONS(n=VALUE(nout->node))){
  467.        VALUE(nout->node)=CONSRIGHT(n);
  468.        nout->node=CONSLEFT(n);
  469.        nout->type=P_ALLNODE;
  470.        return;
  471.      }
  472.      break;
  473.        case P_PLIST:
  474.      if(IS_CONS(n=PLIST(nout->node))){
  475.        PLIST(nout->node)=CONSRIGHT(n);
  476.        nout->node=CONSLEFT(n);
  477.        nout->type=P_ALLNODE;
  478.        return;
  479.      }
  480.        case P_FUNC:
  481.      if(IS_CONS(n=FUNCTION(nout->node))){
  482.        FUNCTION(nout->node)=CONSRIGHT(n);
  483.        nout->node=CONSLEFT(n);
  484.        nout->type=P_ALLNODE;
  485.        return;
  486.      }
  487.        case P_CLASS:
  488.      error(E_BADARGS,ERR_MINTERNAL|ERR_TBLVL|ERR_PNODE,&nin);
  489.      break;
  490.        case P_ALLNODE:
  491.      if(IS_CONS(nout->node)){
  492.        nout->node=CONSLEFT(nout->node);
  493.        return;
  494.      }
  495.      break;
  496.        case P_CONSLEFT:
  497.      if(IS_CONS(n=CONSLEFT(nout->node))){
  498.        CONSLEFT(nout->node)=CONSRIGHT(n);
  499.        nout->node=CONSLEFT(n);
  500.        nout->type=P_ALLNODE;
  501.        return;
  502.      }
  503.      break;
  504.        case P_CONSRIGHT:
  505.      if(IS_CONS(n=CONSRIGHT(nout->node))){
  506.        CONSRIGHT(nout->node)=CONSRIGHT(n);
  507.        nout->node=CONSLEFT(n);
  508.        nout->type=P_ALLNODE;
  509.        return;
  510.      }
  511.      break;
  512.      }
  513.      nin=calc_pointer(nout);
  514.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  515.    }
  516.    error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  517. }
  518.  
  519. void lf_assoc LF_PARAMS
  520. {
  521.  /* (ASSOC <chiave> <a-list> {:TEST <funzione>}? ) */
  522.  /* a-list puo' essere una lista di cons o una lista di liste */
  523.  /* es: ( (a 1) (b 2) ) oppure ( (a . 1) (b . 2) ) */
  524.  /* chiave deve essere un nome */
  525.  
  526.  node key;
  527.  node alist;
  528.  node test=node_alloc("TEST");
  529.  node quote=node_alloc("QUOTE");
  530.  node n;
  531.  node ni;
  532.  node testfunc=NIL;
  533.  
  534.  if(IS_CONS(nin)){
  535.    key=CONSLEFT(nin);
  536.    if(IS_CONS(CONSRIGHT(nin))){
  537.      eval(CONSLEFT(CONSRIGHT(nin)),nout,genv,lenv,EVAL_NORM);
  538.      alist=calc_pointer(nout);
  539.  
  540.      if(IS_CONS(ni=CONSRIGHT(CONSRIGHT(nin)))){
  541.        n=CONSLEFT(ni);
  542.        if(IS_VALUE(n)&&GET_VTYPE(n)==NT_CNAME&&CNAME(n)==test){
  543.      if(IS_CONS(ni=CONSRIGHT(ni))){
  544.        eval(CONSLEFT(ni),nout,genv,lenv,EVAL_NORM);
  545.  
  546.        /* costruisce una lista  */
  547.        /* (key 'CONSLEFT(CONSLEFT(alist)) ) */
  548.        /* da passare alla funzione di test */
  549.  
  550.        TYPE(n=node_make())|=NT_IS_CONS;
  551.        CONSLEFT(n)=NIL; /* qui' vanno i vari CONSLEFT(CONSLEFT(alist)) */
  552.        CONSRIGHT(n)=NIL;
  553.        testfunc=n;     /* n=( nil ) */
  554.  
  555.        TYPE(ni=node_make())|=NT_IS_CONS;
  556.        CONSLEFT(ni)=quote;
  557.        CONSRIGHT(ni)=n;   /* ni= (quote nil) */
  558.  
  559.        TYPE(n=node_make())|=NT_IS_CONS;
  560.        CONSLEFT(n)=ni;
  561.        CONSRIGHT(n)=NIL;  /* n=((quote nil)) */
  562.  
  563.        TYPE(ni=node_make())|=NT_IS_CONS;
  564.        CONSLEFT(ni)=key;
  565.        CONSRIGHT(ni)=n;  /* ni=(key (quote nil)) */
  566.  
  567.        n=testfunc;
  568.        testfunc=calc_pointer(nout);
  569.  
  570.        while(IS_CONS(alist)){
  571.          if(IS_CONS(CONSLEFT(alist))){
  572.            CONSLEFT(n)=CONSLEFT(CONSLEFT(alist));
  573.            /* ni=(key (quote (car(car alist)))) */
  574.            apply_func(testfunc,ni,nout,genv,lenv,EVAL_NORM);
  575.            if(calc_pointer(nout)!=NIL){
  576.          nout->node=alist;
  577.          nout->type=P_CONSLEFT;
  578.          return;
  579.            }
  580.          }
  581.          alist=CONSRIGHT(alist);
  582.        }
  583.        nout->node=NIL;
  584.        nout->type=P_ALLNODE;
  585.        return;
  586.      }
  587.      error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  588.        }
  589.        error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n);
  590.      }else{
  591.        eval(key,nout,genv,lenv,EVAL_NORM);
  592.        key=calc_pointer(nout);
  593.        if( ! (IS_NAME(key)&&HAS_NAME(key)))
  594.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&key);
  595.        while(IS_CONS(alist)){
  596.      if(IS_CONS(CONSLEFT(alist))){
  597.        if(key==CONSLEFT(CONSLEFT(alist))){
  598.          nout->node=alist;
  599.          nout->type=P_CONSLEFT;
  600.          return;
  601.        }
  602.      }
  603.      alist=CONSRIGHT(alist);
  604.        }
  605.      }
  606.      nout->node=NIL;
  607.      nout->type=P_ALLNODE;
  608.      return;
  609.     }
  610.   }
  611.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  612. }
  613.  
  614.  
  615.  
  616.  
  617.